home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / lisp / eulisp / mpfeel.lha / MPFeel / Modules / pretty.em < prev    next >
Lisp/Scheme  |  1992-10-06  |  11KB  |  334 lines
  1. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  2. ;;                                                                           ;;
  3. ;;  EuLisp Module                     Copyright (C) University of Bath 1991  ;;
  4. ;;                                                                           ;;
  5. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  6.  
  7. ;; Pretty printer based on the A.C.Norman Prettyprinter, and distributed
  8. ;; with Reduce, and used in Cambridge LISP
  9. ;;  Translated to EuLisp by John Fitch 1991 Jan 1
  10. ;;                          Copyright Codemist Ltd
  11.  
  12. (defmodule pretty
  13.  
  14.   (standard
  15.    trace
  16.    ; loops
  17.    (rename ((cprog prog)) prog)
  18.    (except (prog) do-macs)) ()
  19.  
  20.   ()
  21.  
  22.   (defgeneric explode-to-list (x))
  23.   (defmethod explode-to-list ((x object)) (generic-convert x '(a list)))
  24.   (defmethod explode-to-list ((x symbol)) (explode x))
  25.   (defmethod explode-to-list ((x string))
  26.     (let ((ans nil))
  27.       (dotimes i 1 (string-length x) (setq ans (cons (string-ref x i) ans)))
  28.       (nreverse ans)))
  29.   (defmethod explode-to-list ((x integer))
  30.     (if (>= x 0) (explode-int x)
  31.       (cons #\- (explode-int (- x)))))
  32.  
  33.   (defun explode-int (x)
  34.     (let ((ans nil))
  35.       (if (> x 9) (setq ans (explode-int (/ x 10))) nil)
  36.       (append ans (cdr (assoc (remainder x 10)
  37.                   '((0 . (#\0)) (1 . (#\1)) (2 . (#\2)) (3 . (#\3))
  38.                 (4 . (#\4)) (5 . (#\5)) (6 . (#\6)) (7 . (#\7))
  39.                 (8 . (#\8)) (9 . (#\9))) equal)))))
  40.  
  41.   (defmethod explode-to-list ((x character))
  42.     (cond ((equal x #\space) '(#\# #\\ #\s #\p #\a #\c #\e))
  43.       ((equal x #\newline) '(#\# #\\ #\n #\e #\w #\l #\i #\n #\e))
  44.       ((equal x #\alert) '(#\# #\\ #\a #\l #\e #\r #\t))
  45.       ((equal x #\backspace)
  46.        '(#\# #\\ #\b #\a #\c #\k #\s #\p #\a #\c #\e))
  47.       ((equal x #\delete) '(#\# #\\ #\d #\e #\l #\e #\t #\e))
  48.       ((equal x #\formfeed) '(#\# #\\ #\f #\o #\r #\m #\f #\e #\e #\d))
  49.       ((equal x #\linefeed) '(#\# #\\ #\l #\i #\n #\e #\f #\e #\e #\d))
  50.       ((equal x #\return) '(#\# #\\ #\r #\e #\t #\u #\r #\n))
  51.       ((equal x #\tab) '(#\# #\\ #\t #\a #\b ))
  52.       ((equal x #\vertical-tab)
  53.        '(#\# #\\ #\v #\e #\r #\t #\i #\c #\a #\l #\- #\t #\a #\b))
  54.       (t (list #\# #\\ x))))
  55.  
  56.   (deflocal ppformat-table (make-table eq))
  57.  
  58.   (deflocal bn nil)
  59.   (deflocal bufferi nil)
  60.   (deflocal buffero nil)
  61.   (deflocal indblanks nil)
  62.   (deflocal indentlevel nil)
  63.   (deflocal initialblanks nil)
  64.   (deflocal pendingrpars nil)
  65.   (deflocal rmar nil)
  66.   (deflocal rparcount nil)
  67.   (deflocal stack nil)
  68.  
  69.   (deflocal *symmetric nil)
  70.   (deflocal thin* 5)
  71.   (defconstant *linelength* 70)
  72.   (deflocal lmar 0)
  73.  
  74.   (defun superprintm (xxx leftmar)
  75.     (progn 
  76.       (superprinm xxx leftmar)
  77.       (newline)
  78.       xxx))
  79.   (export superprintm)
  80.  
  81.   (defun superprinm (x leftmar)
  82.       (setq lmar leftmar)
  83.       (setq bufferi (setq buffero (list nil)))
  84.       (setq initialblanks 0)
  85.       (setq rparcount 0)
  86.       (setq indblanks 0)
  87.       (setq rmar (- *linelength* 3))
  88.       (cond
  89.          ((< rmar 25)
  90.       (error 0 (list (+ rmar 3)
  91.              "Linelength too short for superprinting"))))
  92.       (setq bn 0)
  93.       (setq indentlevel 0)
  94.       (cond ((>= (+ lmar 20) rmar) (setq lmar (- rmar 21))))
  95.       (prindent x (+ lmar 3))
  96.       (overflow 'none)
  97.       x)
  98.   (export superprinm)
  99.  
  100.   (defun prettyprint (xxx) (superprintm xxx 0))
  101.   (export prettyprint)
  102.  
  103.   (defun prindent (x n)
  104.     (cond
  105.        ((atom x) (cond
  106.           ((vectorp x) (prvector x n))
  107.           (t (mapc putch
  108.                (if *symmetric
  109.                    (if (stringp x) (explodes x)
  110.                  (explodefun x))
  111.                  (explode-to-list x))))))
  112.        ((quotep x) (putch #\') (prindent (cadr x) (+ n 1)))
  113.        (t (let ((cx nil))
  114.         (tagbody 
  115.         (cond
  116.                ((> (* 4 n) (* 3 rmar))
  117.         (overflow 'all)
  118.         (setq n (/ n 8))
  119.         (cond ((> initialblanks n)
  120.                (setq lmar (+ (- lmar initialblanks) n))
  121.                (setq initialblanks n)))))
  122.             (setq stack (cons (list n nil 0) stack))
  123.             (putch (cons 'lpar (car stack)))
  124.             (setq cx (car x))
  125.             (prindent cx (+ n 1))
  126.             (cond ((and (symbolp cx) (not (atom (cdr x))))
  127.            (setq cx (table-ref ppformat-table cx)))
  128.           (t (setq cx nil)))
  129.             (cond ((and (equal cx 2) (atom (cddr x))) (setq cx nil)))
  130.             (cond ((eq cx 'prog)
  131.            (putch #\space)
  132.            (prindent (car (setq x (cdr x))) (+ n 3))))
  133.             (setq x (cdr x))
  134.       scan  (cond ((atom x) (go outt)))
  135.             (finishpending)
  136.             (cond ((eq cx 'prog)
  137.            (putblank)
  138.            (overflow bufferi)
  139.            (cond ((atom (car x))
  140.               (setq lmar (setq initialblanks
  141.                        (max (- lmar 6) 0)))
  142.               (prindent (car x) (- n 3))
  143.               (setq x (cdr x))
  144.               (cond ((and (not (atom x)) (atom (car x)))
  145.                  (go scan)))
  146.               (if (> (+ lmar bn) n)
  147.                   (putblank)
  148.                 (dotimes i (+ lmar bn) (- n 1)
  149.                      (putch #\space)))
  150.               (cond ((atom x) (go outt))))))
  151.           ((numberp cx)
  152.            (setq cx (- cx 1))
  153.            (cond ((equal cx 0) (setq cx nil)))
  154.            (putch #\space))
  155.           (t (putblank)))
  156.             (prindent (car x) (+ n 3))
  157.             (setq x (cdr x))
  158.             (go scan)
  159.       outt  (cond ((not (null x))
  160.                    (finishpending)
  161.            (putblank)
  162.            (putch #\.)
  163.            (putch #\space)
  164.            (prindent x (+ n 5))))
  165.             (putch (cons 'rpar (- n 3)))
  166.             (cond ((and
  167.             (equal (cadr (car stack)) 'indent)
  168.             (not (null (cdddr (car stack)))) )
  169.            (overflow (car (cdddr (car stack)))) )
  170.           (t (endlist (car stack))))
  171.             (setq stack (cdr stack)))))))
  172.  
  173.  
  174. (defun prvector (x n)
  175.   (let ((bound nil))
  176.     (setq bound (vector-length x))
  177.     (setq stack (cons (list n nil 0) stack))
  178.     (putch (cons 'lsquare (car stack)))
  179.     (prindent (vector-ref x 0) (+ n 3))
  180.     (dotimes i 1 bound 
  181.          (putch #\,)
  182.          (putblank)
  183.          (prindent (vector-ref x i) (+ n 3)))
  184.     (putch (cons 'rsquare (- n 3)))
  185.     (endlist (car stack))
  186.     (setq stack (cdr stack))))
  187.  
  188. (defun putblank ()
  189.   (putch (car stack))
  190.   ((setter car) (cddr (car stack)) (+ (caddr (car stack)) 1))
  191.   ((setter cdr) (cddr (car stack)) (cons bufferi (cdddr (car stack))))
  192.   (setq indblanks (+ indblanks 1)))
  193.  
  194. (defun endlist (l) (setq pendingrpars (cons l pendingrpars)))
  195.  
  196. (defun finishpending ()
  197.   (mapc (lambda (stackframe)
  198.       (cond
  199.        ((not (equal (cadr stackframe) 'indent))
  200.         (mapc (lambda (b)
  201.             ((setter car) b #\space)
  202.             (setq indblanks (- indblanks 1)))
  203.           (cdddr stackframe))
  204.         ((setter cdr) (cddr stackframe) t)))
  205.       (car stackframe))
  206.     pendingrpars)
  207.   (setq pendingrpars nil))
  208.  
  209. (defun quotep (x)
  210.    (and (not (atom x)) (eq (car x) 'quote)
  211.     (not (atom (cdr x))) (null (cddr x))))
  212.  
  213. ((setter table-ref) ppformat-table 'prog 'prog)
  214. ((setter table-ref) ppformat-table 'lambda 1)
  215. ((setter table-ref) ppformat-table 'setq 1)
  216. ((setter table-ref) ppformat-table 'set 1)
  217. ((setter table-ref) ppformat-table 'dynamic-setq 1)
  218. ((setter table-ref) ppformat-table 'while 1)
  219. ((setter table-ref) ppformat-table 't 1)
  220. ((setter table-ref) ppformat-table 'defun 2)
  221. ((setter table-ref) ppformat-table 'defmethod 2)
  222. ((setter table-ref) ppformat-table 'defgeneric 2)
  223. ((setter table-ref) ppformat-table 'defmacro 2)
  224. ((setter table-ref) ppformat-table 'deflocal 3)
  225. ((setter table-ref) ppformat-table 'defconstant 3)
  226. ((setter table-ref) ppformat-table 'let 1)
  227. ((setter table-ref) ppformat-table 'dynamic-let 1)
  228. ((setter table-ref) ppformat-table 'let* 1)
  229. ((setter table-ref) ppformat-table 'if 2)
  230. ((setter table-ref) ppformat-table 'dotimes 3)
  231. ;;((setter table-ref) ppformat-table 'mapc 4)
  232.  
  233. (defun putch (c)
  234.   (let ((nocheck nil))
  235.     (cond
  236.      ((atom c) (setq rparcount 0))
  237.      ((numberp (car c))
  238.       (setq rparcount 0)
  239.       (setq nocheck t))
  240.      ((eq (car c) 'rpar)
  241.       (setq rparcount (+ rparcount 1))
  242.       (cond
  243.        ((> rparcount 4)
  244.     (putch #\space)
  245.     (setq rparcount 2))))
  246.      (t (setq rparcount 0)))
  247.     (if nocheck nil (while (>= (+ lmar bn) rmar) (overflow 'more)))
  248.     ((setter cdr) bufferi (list c))
  249.     (setq bufferi (cdr bufferi))
  250.     (setq bn (+ bn 1))))
  251.  
  252. (defun overflow (flg)
  253.   (prog (c blankstoskip)
  254.     (cond
  255.          ((and
  256.        (= indblanks 0)
  257.              (> initialblanks 3)
  258.              (eq flg 'more))
  259.                (setq initialblanks (- initialblanks 3))
  260.                (setq lmar (- lmar 3))
  261.                (return 'moved-left)))
  262. fblank(cond
  263.          ((= bn 0)
  264.                (cond ((not (eq flg 'more)) (return 'empty)))
  265.                (cond ((atom (car buffero)) (prin "%+")))
  266.                (newline)
  267.                (setq lmar 0)
  268.                (return 'continued))
  269.          (t (dotimes i 1 initialblanks (prin #\space))
  270.         (setq initialblanks 0)))
  271.       (setq buffero (cdr buffero))
  272.       (setq bn (- bn 1))
  273.       (setq lmar (+ lmar 1))
  274.       (setq c (car buffero))
  275.       (cond
  276.          ((atom c) (prin c) (go fblank))
  277.          ((numberp (car c))
  278.             (cond
  279.                ((not (atom blankstoskip))
  280.                      (prin #\space)
  281.                      (setq indblanks (- indblanks 1))
  282.                      (cond
  283.                         ((eq c (car blankstoskip))
  284.                               ((setter cdr)
  285.                                  blankstoskip
  286.                                  (- (cdr blankstoskip) 1))
  287.                               (cond
  288.                                  ((equal (cdr blankstoskip) 0)
  289.                                     (setq blankstoskip t)))))
  290.                      (go fblank))
  291.                (t (go blankfound))))
  292.          ((or (eq (car c) 'lpar) (eq (car c) 'lsquare))
  293.                (prin (if (eq (car c) 'lpar) #\( #\[))
  294.                (cond ((eq flg 'none) (go fblank)))
  295.                (setq c (cdr c))
  296.                (cond ((not (null (cdddr c))) (go fblank)))
  297.                (cond
  298.                   ((> (car c) indentlevel)
  299.            (setq indentlevel (car c))
  300.            ((setter car) (cdr c) 'indent)))
  301.                (go fblank))
  302.          ((or (eq (car c) 'rpar) (eq (car c) 'rsquare))
  303.                (cond
  304.                   ((< (cdr c) indentlevel) (setq indentlevel (cdr c))))
  305.                (prin (if (eq (car c) 'rpar) #\) #\]))
  306.                (go fblank))
  307.          (t (error 0 (list c "UNKNOWN TAG IN OVERFLOW"))))
  308. blankfound
  309.       (cond ((eqcar (cdddr c) buffero) ((setter cdr) (cddr c) nil)))
  310.       (setq indblanks (- indblanks 1))
  311.       (cond
  312.          ((> (car c) indentlevel)
  313.                (cond ((eq flg 'none) (prin #\space) (go fblank)))
  314.                (cond
  315.                   (blankstoskip (setq blankstoskip nil))
  316.                   (t (setq indentlevel (car c))
  317.              ((setter car) (cdr c) 'indent))) ))
  318.       (cond
  319.          ((> (caddr c) (- thin* 1))
  320.                (setq blankstoskip (cons c (- (caddr c) 2)))
  321.                ((setter car) (cdr c) 'thin)
  322.                ((setter car) (cddr c) 1)
  323.                (setq indentlevel (- (car c) 1))
  324.                (prin #\space)
  325.                (go fblank)))
  326.       ((setter car) (cddr c) (- (caddr c) 1))
  327.       (newline)
  328.       (setq lmar (setq initialblanks (car c)))
  329.       (cond ((eq buffero flg) (return 'to!-flg)))
  330.       (cond ((or blankstoskip (not (eq flg 'more))) (go fblank)))
  331.       (return 'more)))
  332.  
  333. )
  334.